home *** CD-ROM | disk | FTP | other *** search
/ HPAVC / HPAVC CD-ROM.iso / FONTEDIT.ZIP / FONTEDM.PAS < prev    next >
Pascal/Delphi Source File  |  1995-12-21  |  5KB  |  212 lines
  1. Uses Mouser,Crt,Dos;
  2.  
  3. Const AA : Array[1..16,1..16] Of Byte =
  4.  
  5. (
  6. (0,0,0,0,0,0,0,1,1,0,0,0,0,0,0,0),
  7. (0,0,0,0,0,0,1,2,6,1,0,0,0,0,0,0),
  8. (0,0,0,0,0,1,7,5,5,6,1,0,0,0,0,0),
  9. (0,0,0,0,1,7,6,6,6,6,6,1,0,0,0,0),
  10. (0,0,0,1,7,7,7,7,7,7,7,6,1,0,0,0),
  11. (0,0,1,7,8,8,8,8,8,8,8,8,6,1,0,0),
  12. (0,1,7,2,2,2,2,3,4,2,2,2,2,6,1,0),
  13. (1,7,8,8,8,8,3,1,1,6,8,8,8,8,5,0),
  14. (1,7,7,7,7,3,1,0,0,1,6,7,7,7,4,0),
  15. (1,7,6,6,6,3,1,0,0,1,7,6,6,6,3,0),
  16. (1,7,5,5,5,3,1,1,1,1,8,5,5,5,3,0),
  17. (1,7,4,4,4,5,6,7,8,2,8,4,4,4,3,0),
  18. (1,7,5,5,5,4,4,4,4,4,5,5,5,5,3,0),
  19. (1,6,8,7,6,3,1,1,1,1,6,8,7,6,3,0),
  20. (1,5,3,3,3,3,1,0,0,1,5,3,3,3,3,0),
  21. (1,1,1,1,1,1,0,0,0,1,1,1,1,1,1,0));
  22.  
  23. Open : Boolean = False;
  24.  
  25. Var
  26.    Lb,Rb : Boolean;
  27.    Grid : Array[1..16,1..16] Of Byte;
  28.    X,Y,Z,col,start : Byte;
  29.    ch : Char;
  30.    F : Text;
  31.  
  32.  
  33. Procedure SetGrid;
  34. Begin
  35.      For X := 1 To 16 Do
  36.      For Y := 1 To 16 Do
  37.      Begin
  38.           Grid[X,Y] := 0;
  39.           Gotoxy(X,Y); Write('+');
  40.      end;
  41.      Col := 1;
  42. end;
  43.  
  44.  
  45. Procedure Load;
  46. Var X,Y : Word;
  47. Begin
  48.      X := 1; Y :=1;
  49.      TextColor(15);
  50.      Setgrid;
  51.  
  52.      For X := 1 to 16 Do
  53.      For Y := 1 To 16 Do
  54.      Grid[Y,X] := AA[Y,X];
  55.  
  56.  
  57.      For Y := 1 To 16 do Begin
  58.      For X := 1 To 16 Do Begin
  59.      If Grid[y,x] <> 0 Then Begin Gotoxy(X,Y); TextColor(Grid[y,x]);
  60.      Write('█'); end;
  61.      end;
  62. end;
  63.      Gotoxy(20,20); Write('This Is The A Font From SoftRock.Fnt By Grant Smith');
  64.      Gotoxy(20,21); Write('See It Can Be Done So This Prog Aint So Bad');
  65.      exit;
  66. end;
  67.  
  68. Procedure SaveIt;
  69. Begin
  70.      If Not Open Then Assign(F,ParamStr(1));
  71.      If Not Open Then Rewrite(F);
  72.      Open := True;
  73.  
  74.      Writeln(F,'Const E : Array[1..16,1..16] Of Byte =');
  75.  
  76.      For Y := 1 To 16 Do Begin
  77.      For X := 1 To 16 Do Begin
  78.  
  79.      If (Z = 1) And (Start = 1) Then Write(F,'((',Grid[X,Y],',') else
  80.      If Z = 1 Then Write(F,'(',Grid[X,Y],',') else
  81.      If (Z = 16) Then Write(F,Grid[X,Y],'),') else
  82.      Write(F,Grid[X,Y],',');
  83.      Inc(Start);
  84.  
  85.      Inc(Z);
  86.      If Z = 17 Then
  87.      Begin
  88.           Z := 1;
  89.           Writeln(f);
  90.      end;
  91. end;
  92. end;
  93.  
  94.     Writeln(F);
  95.     Start := 1;
  96. end;
  97.  
  98.  
  99. Procedure NewFont;
  100. Begin
  101.      TextColor(15);
  102.      SaveIt;
  103.      SetGrid;
  104. end;
  105.  
  106.  
  107.  
  108. Procedure Keys;
  109. Begin
  110.      If Ch = '1' Then Col := 1;
  111.      If Ch = '2' Then Col := 2;
  112.      If Ch = '3' Then Col := 3;
  113.      If Ch = '4' Then col := 4;
  114.      If Ch = '5' Then Col := 5;
  115.      If Ch = '6' Then Col := 6;
  116.      If Ch = '7' Then Col := 7;
  117.      If Ch = '8' Then Col := 8;
  118.      If ch = #13 Then Load;
  119.      If (Ch = 'n') Or (Ch = 'N') Then NewFont;
  120.      Ch := #23;
  121.      If KeyPressed Then Ch := Readkey;
  122.      TextColor(Col);
  123.      exit;
  124. end;
  125.  
  126. procedure Range;
  127. Begin
  128.      MouseRange(0,0,15,15);
  129. end;
  130.  
  131. Begin
  132.      Start := 1;
  133.      If ParamCount < 1 Then
  134.      Begin
  135.           Writeln('Please Specify A Filename To Save To');
  136.           Writeln('e.g Fonted C:\A.Fnt');
  137.           Halt;
  138.      end;
  139.  
  140.      ClrScr;
  141.      Writeln('Font Editor By Darius Sutherland Crucial D');
  142.      Writeln('Very Basic But Can Produce 16x16 Fonts');
  143.      Writeln('Fonts Depend On Creative Skill');
  144.      Readkey;
  145. asm
  146.     mov ax,0100h
  147.     mov cx,2607h
  148.     int 10h
  149. end;
  150.      TextBackGround(0); TextColor(15); Clrscr; LoadMouse;
  151.      Gotoxy(20,10); Write('       Numbers 1 To 8 To Change Colors');
  152.      Gotoxy(20,11); Write('Enter Loads The Ripped Font "A" From SoftRock.Fnt');
  153.      Gotoxy(20,12); Write('   N Starts A New Font + Saves Last To File');
  154.      Gotoxy(20,13); Write('            Use Mouse Lb/Rb To Edit');
  155.      Gotoxy(20,14); Write('   Escape Ends Session And Save Existing Fonts');
  156.  
  157.      Z := 1;
  158.      For X := 1 To 16 Do
  159.      For Y := 1 To 16 Do
  160.          Grid[X,Y] := 0;
  161.          MouseXy(24,70);
  162.          MouseRange(0,0,15,15);
  163.          SetGrid;
  164.          Ch := #0;
  165.          TextColor(Col);
  166.  
  167.          REPEAT
  168.  
  169.          If KeyPressed Then Keys;
  170.          Buttons(Lb,Rb,Lb,Rb);
  171.          {Keys;}
  172.  
  173.          If Lb Then
  174.          Begin
  175.               X := Xpos+1; Y := Ypos+1;
  176.               MouseOff;
  177.               Gotoxy(X,Y);
  178.               Write('█');
  179.               Grid[X,Y] := Col;
  180.               MouseXy(X-1,Y-1);
  181.               LoadMouse;
  182.               Range;
  183.          end;
  184.  
  185.          If Rb Then
  186.          Begin
  187.                X := Xpos+1; Y := Ypos+1;
  188.                MouseOff;
  189.                Gotoxy(X,Y);
  190.                TextColor(15);
  191.                Write('+');
  192.                TextColor(Col);
  193.                MouseXy(X-1,Y-1);
  194.                LoadMouse;
  195.                Grid[X,Y] := 0;
  196.                Range;
  197.          end;
  198.  
  199.  
  200.          UNTIL Ch = #27;
  201.  
  202.     SaveIt;
  203.     If Open Then Close(f);
  204.     TextColor(15);
  205.     TextBackGround(0);
  206.     Clrscr;
  207.     Writeln('Font Editor By Darius Sutherland Crucial D');
  208.     Writeln('All Fonts Save To File');
  209.     Writeln;
  210.     Writeln('18.12.95');
  211. end.
  212.